home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / debug.scm.z / debug.scm
Text File  |  2002-07-08  |  3KB  |  118 lines
  1. ;;;;     Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; The author can be reached at djurfeldt@nada.kth.se
  19. ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  20. ;;;;
  21.  
  22.  
  23. (define-module (ice-9 debug))
  24.  
  25.  
  26. ;;; {Misc}
  27. ;;;
  28. (define-public (frame-number->index n . stack)
  29.   (let ((stack (if (null? stack)
  30.            (fluid-ref the-last-stack)
  31.            (car stack))))
  32.     (if (memq 'backwards (debug-options))
  33.     n
  34.     (- (stack-length stack) n 1))))
  35.  
  36.  
  37. ;;; {Trace}
  38. ;;;
  39. ;;; This code is just an experimental prototype (e. g., it is not
  40. ;;; thread safe), but since it's at the same time useful, it's
  41. ;;; included anyway.
  42. ;;;
  43. (define traced-procedures '())
  44.  
  45. (define-public (trace . args)
  46.   (if (null? args)
  47.       (nameify traced-procedures)
  48.       (begin
  49.     (for-each (lambda (proc)
  50.             (if (not (procedure? proc))
  51.             (error "trace: Wrong type argument:" proc))
  52.             (set-procedure-property! proc 'trace #t)
  53.             (if (not (memq proc traced-procedures))
  54.             (set! traced-procedures
  55.                   (cons proc traced-procedures))))
  56.           args)
  57.     (set! apply-frame-handler trace-entry)
  58.     (set! exit-frame-handler trace-exit)
  59.     (set! trace-level 0)
  60.     (debug-enable 'trace)
  61.     (nameify args))))
  62.  
  63. (define-public (untrace . args)
  64.   (if (and (null? args)
  65.        (not (null? traced-procedures)))
  66.       (apply untrace traced-procedures)
  67.       (begin
  68.     (for-each (lambda (proc)
  69.             (set-procedure-property! proc 'trace #f)
  70.             (set! traced-procedures (delq! proc traced-procedures)))
  71.           args)
  72.     (if (null? traced-procedures)
  73.         (debug-disable 'trace))
  74.     (nameify args))))
  75.  
  76. (define (nameify ls)
  77.   (map (lambda (proc)
  78.      (let ((name (procedure-name proc)))
  79.        (or name proc)))
  80.        ls))
  81.  
  82. (define trace-level 0)
  83. (add-hook! abort-hook (lambda () (set! trace-level 0)))
  84.  
  85. (define (trace-entry key cont tail)
  86.   (if (eq? (stack-id cont) 'repl-stack)
  87.       (let ((cep (current-error-port))
  88.         (frame (last-stack-frame cont)))
  89.     (if (not tail)
  90.         (set! trace-level (+ trace-level 1)))
  91.     (let indent ((n trace-level))
  92.       (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
  93.     (display-application frame cep)
  94.     (newline cep)))
  95.   ;; It's not necessary to call the continuation since
  96.   ;; execution will continue if the handler returns
  97.   ;(cont #f)
  98.   )
  99.  
  100. (define (trace-exit key cont retval)
  101.   (if (eq? (stack-id cont) 'repl-stack)
  102.       (let ((cep (current-error-port)))
  103.     (set! trace-level (- trace-level 1))
  104.     (let indent ((n trace-level))
  105.       (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
  106.     (write retval cep)
  107.     (newline cep))))
  108.  
  109.  
  110. ;;; A fix to get the error handling working together with the module system.
  111. ;;;
  112. (variable-set! (builtin-variable 'debug-options) debug-options)
  113.  
  114.  
  115.  
  116. (debug-enable 'debug)
  117. (read-enable 'positions)
  118.